Pass3Xa.mesa 2-Sep-78 12:59:59 Page X 



-- file Pass3Xa.Mesa 

-- last modified by Satterthwaite, July 16, 1978 10:11 AM 

DIRECTORY 

ComData: FROM "comdata" 
USING [ 

idCARDINAL, ownSymbols , seAnon, 

typeCHARACTER. typeCONDITION, typelNTEGER. typeSTRING, xref], 
ErrorDefs: FROM "errordefs" USING [error, errorhti, errorn, errortree], 
P3Defs: FROM "pSdefs" 
USING [ 

ArrangeKeys, BumpCount, Bundling, CanonicalType, CatchPhrase, 

CompleteRecord, Definedid, Exp, Fieldid, ForceType, 

MakeLongType, MakePointerType, OperandType, PopCtx, PushCtx, 

RConst, RecordReference, Rhs, RPop, RPush, RType, 

TargetType, TypeExp, TypeForTree, Unbundle, VariantUnionType, VoidExp, 

XferBody, XferForFrame, 

CheckExprLoop] , 
PassS: FROM "passS" USING [impl icitRecord , imp! icitType, lockHeld], 
SymDefs: FROM "symdefs" 

USING [bodytype, ctxtype, setype, 

SERecord, 

HTIndex, SEIndex, ISEIndex, CSEIndex, recordCSEIndex, CTXIndex. CBTIndex, 

HTNull, SENull, ISENull, CSENull, BTNull , 

IG, typeANY. typeTYPE], 
SymTabDefs: FROM "symtabdef s" 
USING [ 

Constantid, f irstvisiblese, makenonctxse, NextSe, NormalType, 

TypeForm, TypeRoot, UnderType, visiblectxentries] , 
TableDefs: FROM "tabledefs" USING [TableBase. TableNotif ier], 
TreeDefs: FROM "treedefs" 
USING [treetype. 

NodeName, Treelndex, TreeLink, TreeMap. 

empty, nul ITreelndex, 

freetree, GetNode, IdentityMap, listhead, listlength, listtail, 

makelist, maketree, mlpop, mlpush, pushproperl ist , pushtree, 

setattr, setinfo, testtree, updatelist], 
TypePackDefs: FROM "typepackdefs" 

USING [SymbolTableBase, AssignableTypes, EquivalentTypes]; 

PassSXa: PROGRAM 
IMPORTS 

ErrorDefs, PSDefs, SymTabDefs, TreeDefs, TypePackDefs. 
dataPtr: ComData, passPtr: PassS 
EXPORTS PSDefs « 
BEGIN 
OPEN SymTabDefs, TreeDefs, PSDefs; 

-- pervasive definitions from SymDefs 

SEIndex: TYPE = SymDefs .SEIndex; 
ISEIndex: TYPE = SymDefs . ISEIndex; 
CSEIndex: TYPE = SymDefs .CSEIndex; 
RecordSEIndex: TYPE = SymDefs . recordCSEIndex; 
SENull: SymDefs. SEIndex = SymDef s, SENull ; 
typeANY: SymDef s .CSEIndex = SymDef s . typeANY; 

CTXIndex: TYPE = SymDef s .CTXIndex; 

tb: TableDefs. TableBase; -- tree base address (local copy) 

seb: TableDefs. TableBase; -- se table base address (local copy) 

ctxb: TableDefs. TableBase; -- context table base address (local copy) 

bb: TableDefs. TableBase; -- body table base address (local copy) 

own: TypePackDefs. Symbol TableBase; 

ExpANotify: PUBLIC TableDefs .TableNotif ier » 

BEGIN -- called by allocator whenever table area is repacked 

seb *- base[SymDefs .setype]; ctxb ♦- base[SymDefs. ctxtype]; 

bb ^ base[SymDefs .bodytype] ; 

tb ^ base[treetype]; 

own ^ dataPtr .ownSymbols; RETURN 

END; 
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-- tree manipulation utilities 

OperandLhs: PUBLIC PROCEDURE [t: TreeLink] RETURNS [BOOLEAN] ■ 
BEGIN 

node: Treelndex; 
DO 

WITH t SELECT FROM 
symbol «> 
BEGIN 

IF dataPtr.xref THEN RecordReference[index, Ihs]; 
RETURN ['-(seb+index).writeonce] 
END; 
subtree ■> 

BEGIN node <r index; 

IF node » nul ITreelndex THEN RETURN [FALSE]; 
SELECT (tb+node).name FROM 
dot «> 

RETURN [WITH ( tb+node) . son2 SELECT FROM 
symbol «> ~(seb+index) .writeonce, 
ENDCASE => FALSE]; 
dollar => 

WITH ( tb+node). son2 SELECT FROM 
symbol => 
BEGIN 

IF dataPtr.xref THEN RecordReference[index, Ihs]; 
IF ~(seb+index) .writeonce 
THEN t <- (tb+node). sonl 
ELSE RETURN [FALSE]; 
END; 
ENDCASE => RETURN [FALSE]; 
index, loophole, cast, openexp, align «> t ^ (tb+node) , sonl; 
uparrow, dindex, seqindex, reloc, memory, register «> 

RETURN [TRUE]; 
apply => RETURN [1 istlength[(tb+node) .sonl] « 1]; 
ENDCASE => RETURN [FALSE]; 
END; 
ENDCASE => RETURN [FALSE]; 
ENDLOOP; 
END; 

LongPath: PUBLIC PROCEDURE [t: TreeLink] RETURNS [long: BOOLEAN] = 
BEGIN 

node: Treelndex; 
WITH t SELECT FROM 
subtree => 

BEGIN node <- index; 
IF node = nullTreelndex 
THEN long ^ FALSE 
ELSE SELECT ( tb+node) . name FROM 
loophole, cast, openexp, align «> 
long <- LongPath[(tb+node) .sonl]; 
ENDCASE 

-- dot, uparrow, dindex, reloc, seqindex, dollar, index -- «> 
long ^ (tb+node) .attrl; 
END; 
ENDCASE => long *- FALSE; 
RETURN 
END; 

Operandlnternal: PUBLIC PROCEDURE [t: TreeLink] RETURNS [BOOLEAN] « 
BEGIN 

node: Treelndex; 
WITH t SELECT FROM 
symbol => 
BEGIN 

sei: ISEIndex « index; 
subNode: Treelndex; 
bti: SymDefs.CBTIndex; 

IF ~(seb+sei). constant THEN RETURN [FALSE]; 
IF (seb+sei) .mark4 
THEN 
BEGIN 

bti <r (seb+sei) . idinfo; 

RETURN [bti ^ SymDef s.BTNul 1 AND (bb+bti ). internal ] 
END; 
subNode <- (seb+sei) . idvalue; 
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RETURN [WITH (tb+subNode) . son3 SELECT FROM 

subtree »> (tb+index) .name = body AND (tb+index) .attr2, 
ENDCASE »> FALSE] 
END; 
subtree ■> 

BEGIN node *- index; 

RETURN [SELECT ( tb+node) .name FROM 

dot, cdot, assignx »> Operandlnternal[(tb+node) .son2]. 
ifexp "> 

Operandi nternal [(tb+node) .son2] OR Ope rand Internal [(tb+node) .son3], 
ENDCASE ■> FALSE] -- should check caseexp, bindexp also 
END; 
ENDCASE -> RETURN [FALSE]; 
END; 

-- type manipulation 

DiscriminatedType: PROCEDURE [baseType: CSEIndex, t: TreeLink] RETURNS [CSEIndex] 
BEGIN 

node: Treelndex; 
type: CSEIndex; 
temp: TreeLink; 

IF t = empty THEN RETURN [passPtr . imp! icitRecord]; 
WITH t SELECT FROM 
subtree => 

BEGIN node ♦- index; 
SELECT (tb+node). name FROM 
unionx «=> 
BEGIN 
WITH (tb+node). sonl SELECT FROM 

symbol => type ♦- UnderType[index]; 
ENDCASE => ERROR; 
WITH (seb+type) SELECT FROM 
record => 

RETURN [IF variant AND (temp<-l isttail [(tb+node) . son2]) empty 
THEN DiscriminatedType[type, temp] 
ELSE type]; 
ENDCASE => ERROR; 
END; 
dollar => RETURN [OperandType[(tb+node) . sonl]]; 
dot «> 
BEGIN 

type <- NormalType[OperandType[(tb+node) . sonl]]; 
WITH (seb+type) SELECT FROM 

pointer => RETURN[UnderType[pointedtotype]]; 
ENDCASE => ERROR; 
END; 
assignx => RETURN [DiscriminatedType[baseType, (tb+node) .son2]] ; 
ENDCASE; 
END; 
ENDCASE; 
RETURN [baseType] 
END; 

-- expression list manipulation 

CheckLength: PROCEDURE [t: TreeLink, length: INTEGER] » 
BEGIN 

n: INTEGER = 1 istlength[t] ; 
SELECT n FROM 

= length => NULL; 

> length => ErrorDef s.errorn[l istLong, n~length]; 

< length => ErrorDef s .errorn[l istShort, length-n]; 

ENDCASE; 
RETURN 
END; 

KeyedList: PROCEDURE [t: TreeLink] RETURNS [BOOLEAN] - 
BEGIN 

RETURN [t iff empty AND testtree[l isthead[t] , item]] 
END; 

ContextComplete: PROCEDURE [ctx: CTXIndex] RETURNS [BOOLEAN] « 
BEGIN 
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RETURN [WITH (ctxb+ctx) SELECT FROM 

simple «> TRUE, 

included => ctxcomplete, 

ENDCASE »> FALSE] 
END; 

MatchFields: PUBLIC PROCEDURE [record: RecordSEIndex, expList: TreeLink, elisions: BOOLEAN] 
RETURNS [val: TreeLink] =« 
BEGIN 

nFields: INTEGER; 
ctx: CTXIndex; 
sei: ISEIndex; 

EvaluateField: TreeMap " 
BEGIN 

IF t # empty 
THEN 
BEGIN 

V <r Rhs[t, IF sei « SENun 
THEN typeANY 

ELSE TargetType[UnderType[(seb+sei) . idtype]]]; 
RPop[]; 
END 
ELSE 

BEGIN V ♦- empty; 

IF -elisions AND sei ff SENull THEN ErrorDef s . error[el ision]; 
END; 
IF sei ff SENull THEN sei ^ NextSe[sei]; 
RETURN 
END; 

KeyFillError: PROCEDURE [sei: ISEIndex] RETURNS [TreeLink] « 
BEGIN 

ErrorDefs .errorhti[omittedKey , (seb+sei) .htptr]; 
RETURN [TreeLink[symbol[index: dataPtr. seAnon]]] . 
END; 

IF record = SENull 
THEN 

BEGIN nFields ^ 0; sei ♦- SymDef s . ISENul 1 ; 
IF expList ^ empty 

THEN ErrorDefs. errorn[listLong, 1 istlength[expList]]; 
END 
ELSE 
BEGIN 

CompleteRecord[ record]; 

IF ~ContextComplete[(seb+record) .f ieldctx] 
THEN 

BEGIN ErrorDef s.error[noAccess]; 
nFields <- 0; sei <- SymDef s . ISENull ; 
END 
ELSE 

BEGIN ctx ^ (seb+record) .f ieldctx; 
IF KeyedList[expList] 
THEN 
BEGIN 

nFields ♦- ArrangeKeys[expList, ctx, KeyFillError]; 
expList <r makel ist[nFields] ; 
END 
ELSE 

BEGIN nFields ^ visiblectxentries[ctx] ; 
IF nFields j^ 1 OR expList # empty 

THEN CheckLength[expList, nFields]; 
END; 
sei ♦- f irstvisiblese[ctx]; 
END; 
END; 
IF expList j^ empty 

THEN val <- updatel ist[expList , EvaluateField] 
ELSE 

BEGIN -- resolve length 0/length 1 ambiguity 
IF nFields « 
THEN val ♦- empty 
ELSE 
BEGIN 
IF '-elisions THEN ErrorDefs .error[el ision]; 
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ni1push[empty]; pushproperl ist[l] ; val ^m1pop[]; 

END; 
END; 
RETURN 
END; 

BumpFieldRers: PUBLIC PROCEDURE [record: RecordSEIndex] - 
BEGIN 

sei: ISEIndex; 
IF record # SENuTI 
THEN 

FOR sei ♦- (ctxb+(seb+record).fieldctx).selist, NextSe[sei] UNTIL sei » SENull 
DO BumpCount[sei] ENDLOOP; 
RETURN 
END; 

-- operators 

Dot: PUBLIC PROCEDURE [node: Treelndex] « 
BEGIN OPEN (tb+node); 
type, rType, nType: CSEIndex; 
sei: ISEIndex; 
fieldHti: SymDef s .HTIndex; 
op: NodeName; 

matched, const, long: BOOLEAN; 
nHits: CARDINAL; 
nDerefs: CARDINAL; 

sonl <- Exp[sonl, typeANY]; type ♦- RType[]; RPop[]; 
WITH son2 SELECT FROM 

hash => fieldHti ^ index; 
ENDCASE => ERROR; 
op ^ dollar; nDerefs <- 0; long ♦- LongPath[sonl]; 
-- N.B. failure is avoided only by EXITing the following loop 
DO 

nType <- NormalType[type]; 
WITH (seb+nType) SELECT FROM 
record => 
BEGIN 

[nHits, sei] ^ Fieldld[f iel dHti , LOOPHOLE[nType, RecordSEIndex]]; 
SELECT nHits FROM 

=> NULL; 

1 => EXIT; 

ENDCASE => GO TO ambiguous; 

IF Bundling[nType] = THEN GO TO nomatch; 

type ^ Unbundle[LOOPHOLE[nType, RecordSEIndex]]; 

sonl ♦■ IF op = dot 

THEN Dereference[sonl , type, long] 
ELSE ForceType[sonl , type]; 

op ♦- dollar; 

END; 
pointer «> 

BEGIN 

IF (nDerefs ^ nDerefs+1) > 255 THEN GO TO nomatch; 

IF op = dot THEN sonl ^ Deref erence[sonl , type, long]; 

long <- (seb+type) . typetag = long; 

op <- dot; dereferenced ♦- TRUE; type <- UnderType[pointedtotype]; 

END; 
definition «> 

BEGIN 

[matched, sei] <- Def inedld[f ieldHti , nType]; 

IF matched THEN BEGIN op *- cdot; EXIT END; 

GO TO nomatch; 

END; 
ENDCASE »> GO TO nomatch; 
REPEAT 

nomatch «> 

BEGIN 

IF fieldHti # SymDef s.HTNul 1 

THEN ErrorDefs.errorhti[unknownField, fieldHti]; 

sei ^ dataPtr . seAnon; 

END; 
ambiguous «> 

BEGIN 

ErrorDefs.errorhti[ambiguousId, fieldHti]; sei ^ dataPtr .seAnon; 
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END; 

ENDLOOP; 
son2 <- TreeLink[symbol[index: sei]]; 
rType <- UnclerType[(seb+sei) . idtype]; 
const *- ConstantId[sei]; 
IF const 

THEN name <- cdot 

ELSE BEGIN name ♦- op; attrl ♦- long END; 
RPush[rType, const]; RETURN 
END; 

Dereference: PROCEDURE [t: TreeLink, type: CSEIndex, long: BOOLEAN] RETURNS [TreeLink] 
BEGIN 

mlpush[t]; pushtree[uparrow, 1]; setinfo[type] ; setattr[l, long]; 
RETURN[mlpop[]] 
END; 

UpArrow: PUBLIC PROCEDURE [node: Treelndex] = 
BEGIN OPEN (tb+node); 
type, nType: CSEIndex; 
sonl ^ Exp[sonl, typeANY]; 
type ♦- RType[]; RPop[]; 
DO 

nType ^ NormalType[type]; 
WITH (seb+nType) SELECT FROM 
pointer => 
BEGIN 

dereferenced <- TRUE; RPush[UnderType[pointedtotype] , FALSE]; 
attrl ^ (seb+type) .typetag « long; EXIT 
END; 
record »> 
BEGIN 

IF Bundling[nType] = THEN GO TO fail; 
type ^ Unbundle[L00PHOLE[nType, RecordSEIndex]] ; 
END; 
ENDCASE => GO TO fail; 
REPEAT 
fail »> 
BEGIN 

IF type # typeANY THEN ErrorDef s .errortree[typeClash , sonl]; 
RPush[type, FALSE]; 
END; 
ENDLOOP; 
RETURN 
END; 

Apply: PUBLIC PROCEDURE [node: Treelndex, target: CSEIndex, mustXfer: BOOLEAN] - 
BEGIN OPEN (tb+node); 
opType, type, nType, subType: CSEIndex; 
nDerefs: CARDINAL; 
const, desc, long: BOOLEAN; 

ApplyError: PROCEDURE [warn: BOOLEAN] « 
BEGIN 

IF warn THEN ErrorDef s .errortree[noAppl ication , sonl]; 
son2 <r update! ist[son2, VoidExp]; 
RPusti[typeANY, FALSE]; RETURN 
END; 

UniOperand: PROCEDURE RETURNS [valid: BOOLEAN] = 
BEGIN 

IF -{valid ^ listlength[son2] « 1) 
THEN 
BEGIN 

CheckLengtli[son2, 1]; 
son2 ♦- updatelist[son2, VoidExp]; 
RPush[typeANY, FALSE]; 
END 
ELSE IF KeyedList[son2] THEN ErrorDefs .error[keys]; 
RETURN 
END; 

IF sonl ^ empty 
THEN 
BEGIN 
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WITH (seb+target) SELECT FROM 
union ■> 

BEGIN PushCtx[casectx]; 
sonl ^ Exp[sonl, typeANY]; PopCtx[]; 
END; 
ENDCASE »> sonl ^ Exp[sonl, typeANY]; 
opType *- RType[]; const <- RConst[]; RPop[]; 
IF opType « SymDef s . typeTYPE 

THEN type ^ UnclerType[TypeForTree[sonl]] ; 
END 
ELSE 

BEGIN opType ^ SymDef s . typeTYPE; 
SELECT (seb+target). typetag FROM 
record => type ♦- TypeRoot[target]; 
array «> type ^ target; 
ENDCASE «> 

BEGIN type <- typeANY; 

ErrorDef s .errortree[noTarget , [subtree[nocle]]]; 
END; 
END; 
nDerefs <- 0; desc <- FALSE; long ^ LongPath[sonl]; 
-- dereferencing/deproceduring loop 
DO 

nType <- NormalType[opType]; 
WITH (seb+nType) SELECT FROM 
mode => 
BEGIN 
SELECT (seb+type). typetag FROM 

record => Construct[node, LOOPHOLE[type, RecordSEIndex]]; 
array => RowCons[node, type]; 
enumerated, subrange, basic -> 
IF UniOperand[] 
THEN 
BEGIN 

sonl ♦- Rhs[son2, TargetType[type]]; 
son2 <- empty; name <- loophole; 
const ♦- RConst[]; RPop[]; 
RPush[type, const]; 
END; 
ENDCASE => ApplyError[typejytypeANY]; 
EXIT 
END; 
transfer => 
BEGIN 

SELECT mode FROM 
procedure => 

IF -passPtr . lockHeld AND Operandlnternal[sonl] 
THEN ErrorDef s .errortree[internalCall , sonl]; 
program => 

IF XferBody[sonl] # SymDef s .BTNull 

THEN ErrorDef s.errortree[typeClash, sonl]; 
ENDCASE; 
son2 ♦- MatchFields[inrecord , son2. FALSE]; 
RPush[outrecord, FALSE]; 
name <- SELECT mode FROM 
procedure «> call . 
port => portcall , 
process => join, 
signal => signal, 
error => error, 
program «=> start, 
ENDCASE => apply; 
EXIT 
END; 
array => 
BEGIN 

IF UniOperand[] 
THEN 
BEGIN 

IF KeyedList[son2] THEN ErrorDef s.error[keys] ; 
son2 ♦- Rhs[son2, TargetType[UnderType[indextype]]]; 
END; 
RPop[]; RPush[UnderType[componenttype], FALSE]; 
IF mustXfer 
THEN 
BEGIN 
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opType ^ RType[]; RPop[]; 
m1push[sonl]; ml!P'Ush[son2] ; 
pushtree[IF desc fiHEN dindex ELSE index, 2]; 
setinfo[opType]; setattr[l, long]; 
sonl *- mlpop[]; son2 <- empty; 

IF nsons > 2 THEN ErrorDef s .error[misp1acedCatch] ; 
mustXfer *- FALSE; — to avoid looping 
END 
ELSE 
BEGIN 

name <- IF desc THEH dindex ELSE index; attrl <- long; 
EXIT 
END; 
END; 
arraydesc ■> 
BEGIN 

long ♦- (seb+opType) .typetag = long; 

opType <r UnderType[describedType]; const *- FALSE; desc ^ TRUE; 
END; 
pointer «> 

SELECT TRUE FROM 
basing ■> 
BEGIN 

IF UniOperand[] 
THEN 
BEGIN 

son2 <- Rhs[son2, typeANY]; 
subType ♦- CanofiicalType[RType[]]; 
RPop[]; 

WITH (seb+subType) SELECT FROM 
relative «> 
BEGIN 
IF -TypePackDef s. As sign able Types [ 

[own, UnderType[baseType3], 
[own, opType]] 
THEN ErrorDef s.errortree[typeClash, sonl]; 
type *r UnderType[resul tType]; 
END; 
ENDCASE »> 

BEGIN type ^ typeANY; 
IF subType ff typeANY 

THEN ErrorDef s.errortree[typeClash, son2]; 
END; 
subType *• NormalType[type]; 
attrl <- (seb+opType) .typetag = long 

OR (seb+type) . typetag = long; 
attr2 ^ (seb+subType) .typetag = arraydesc; 
WITH (seb+subType) SELECT FROM 
pointer «> 
BEGIN 

dereferenced ♦- TRUE; type ^ UnderType[pointedtotype]; 
END; 
arraydesc => type ♦- UnderType[describedType] ; 
ENDCASE; 
RPush[type, FALSE]; name <- reloc; 
END; 
EXIT 
END; 
nType » dataPtr . typeSTRING »> 
BEGIN 

IF UniOperand[] 
THEN 

BEGIN dereferenced ♦- TRUE; 
son2 <- Rhs[son2, dataPtr . typelNTEGFR]; 
RPop[]; RPusli[dataPtr.typeCHARACTER, FALSE]; 
name <- seqindex; attrl ^ (seb+opType) .typetag = long; 
END; 
EXIT 
END; 
ENDCASE -> 
BEGIN 

const *- FALSE; 

dereferenced ^ TRUE; subType ^ UnderType[pointedtotype] ; 
WITH (sebfsubType) SELECT FROM 
record »> 

IF (ctxb+fieldctx) .ctxlevel » SymDefs.lG 
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THEN 

BEGIN opType ♦- Xf erForFranie[f iel dctx] ; 
sonl ^ ForceType[sonl, opType]; 
END 
ELSE GO TO deRef; 
ENDCASE -> GO TO deRef; 
EXITS 
deRef »> 
BEGIN 

IF (nDerefs *- nDerefs+1) > 255 THEN GO TO fail; 
long ^ (seb+opType) .typetag « long; 
sonl *- Dereference[sonl, subType, long]; 
opType ^ subType; 
END; 
END; 
record «> 
BEGIN 

IF nType = dataPtr . typeCONDITION 
THEN 
BEGIN 
IF son2 ff empty 

THEN ErrorDef s.errorn[l istLong , 1 istlength[son2]] ; 
RPush[SymDefs.CSENull, FALSE]; 
name <- wait; 
EXIT 
END; 
IF Bundling[opType] = THEN GO TO fail; 
opType <- Unbundle[LOOPHOLE[opType. RecordSEIndex]] ; 
sonl <- ForceType[sonl , opType]; 
END; 
ENDCASE «> GO TO fail; 
REPEAT 

fail => ApplyError[opType#typeANY OR nDerefs^O]; 
ENDLOOP; 
IF nsons > 2 THEN 
BEGIN 
SELECT name FROM 

call, portcall, signal, error, start, fork, Join, wait, apply »> 

NULL; 
ENDCASE => ErrorDefs.error[misplacedCatch]; 
[] *- CatchPhrase[son3]; 
END; 
RETURN 
END; 

Construct: PROCEDURE [node: Treelndex. type: RecordSEIndex] « 
BEGIN OPEN (tb+node); 
cType: CSEIndex ♦- type; 
t: TreeLink; 

son2 <r MatchFields[type, son2. TRUE]; 
WITH (seb+type) SELECT FROM 
linked => 

BEGIN 

name <- unionx; 

cType ^ VariantUnionType[l inktype]; 

END; 
ENDCASE «> 

BEGIN 

name *- constructx; 

IF variant AND ( t*-l isttail [son2]) i^ empty 
THEN cType ^ DiscriminatedType[type, t]; 

END; 
info *- cType; RPush[cType, FALSE]; 
RETURN 
END; 

RowCons: PROCEDURE [node: Treelndex, type: CSEIndex] - 
BEGIN OPEN (tb+node); 

cType: CSEIndex « TargetType[WITH (seb+type) SELECT FROM 
array «> UnderType[componenttype], 
ENDCASE «> typeANY]; 

MapValue: TreeMap ■ 
BEGIN 
IF t # empty 

THEN BEGIN v ♦- Rhs[t, cType]; RPop[] END 
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ELSE V ♦- empty; 
RETURN 
END; 

IF KeyedList[son2] THEN ErrorDef s .error[keys] ; 

son2 +- update! ist[son2, MapValue]; 

name ♦- rowconsx; info ^ type; 

RPushCtype, FALSE]; 

END; 



Assignment: PUBLIC PROCEDURE [node: Treelndex] ■ 
BEGIN OPEN (tb+node); 
IhsType, rhsType: CSEIndex; 

sonl *- Exp[sonl, typeANY I CheckExprLoop => RESUME [FALSE]]; 
IF '-OperandLhs[sonl] THEN ErrorDef s. errortree[nonLHS, sonl]; 
IhsType <- RType[]; RPop[]; 
son2 <- Rhs[son2, TargetType[1hsType]]; 
IF (seb+lhsType) . typetag = union 
THEN 

IF ~TypePackDefs.Assignab1eTypes[ 
[own, DiscriminatedType[typeANY, sonl]], 
[own, DiscriminatedType[typeANY, son2]]] 
THEN ErrorDefs.errortree[typeClash, son2]; 
rhsType ^ RType[]; RPop[]; 
RPush[rhsType, FALSE]; RETURN 
END; 



Extract: PUBLIC PROCEDURE [node: Treelndex] « 
BEGIN OPEN (tb+node); 
type: CSEIndex; 
ctx: CTXIndex; 
sei: ISEIndex; 
nL, nR: CARDINAL; 
saveRecord: RecordSEIndex = passPtr. imp! icitRecord; 

FillNull: PROCEDURE [ISEIndex] RETURNS [TreeLink] « 
BEGIN 

RETURN [empty] 
END; 

Pushltem: TreeMap ■ 
BEGIN 

mlpush[t]; RETURN [empty]; 
END; 

Assignltem: TreeMap » 
BEGIN 

saveType: CSEIndex « passPtr. imp! ici tType; 
IF t = empty 
THEN V <- empty 
ELSE 
BEGIN 

passPtr. impl icitType <- IF sei =• SENull 
THEN typeANY 

ELSE UnderType[(seb+sei) . id type]; 
mlpush[t]; mlpush[empty] ; v ^ maketree[assign , 2]; 
Assignment[GetNode[v]]; RPop[]; 
END; 
IF sei ^ SENun THEN sei <- NextSe[sei]; 
passPtr. imp! icitType <- saveType; RETURN 
END; 

son2 ♦- Exp[son2, typeANY]; type <- RType[]; RPop[]; 
IF type » SENun 
THEN 

BEGIN ErrorDef s.errortree[typeClash , son2]; 
type ♦- typeANY; nR <- 0; sei <- SymDef s. ISENull ; 
END 
ELSE 
BEGIN 

type <- TypeRoot[type]; 
WITH (seb+type) SELECT FROM 
record »> 
BEGIN 
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ConipleteRecord[LOOPHOLE[type, RecordSEIndex]] ; 
IF ContextComplete[f ieldctx] 
THEN 
BEGIN 

passPtr. implicitRecord <- LOOPHOLE[typ0 , RecordSEIndex]; 
ctx ♦- fieldctx; sei <- Firstvisib1ese[ctx]; 
nR *- visib1ectxentries[ctx] ; 
END 
ELSE 

BEGIN ErrorDef s .error[noAccess]; 
type ^ typeANY; nR ♦- 0; sei ♦- SymDef s .ISENull ; 
END; 
END; 
ENDCASE »> 
BEGIN 

IF type # typeANY THEN ErrorDef s .errortree[typeClash, son2]; 
type <- typeANY; nR ^ 0; sei ♦- SymDef s. ISENull ; 
END; 
END; 
IF KeyedList[sonl] AND type ^ typeANY 

THEN nL <- ArrangeKeys[sonl , ctx, FillNull] 
ELSE 
BEGIN 

nL *- 1 istlength[sonl]; 

sonl <- f reetree[updatel ist[sonl , Pushltem]]; 
IF nL > nR AND type ff typeANY 

THEN ErrorDef s .errorn[l istLong, nL-nR]; 
THROUGH (nL .. nR] DO mlpush[enipty] ENDLOOP; 
nL <r MAX[nL, nR]; 
END; 
pushproperlist[nR]; setinf o[type]; 
sonl <r update! ist[mlpop[], Assignltem]; 
passPtr. impl icitRecord <- saveRecord; RETURN 
END; 



Addr: PUBLIC PROCEDURE [node: Treelndex, target: CSEIndex] » 
BEGIN OPEN (tb+node); 
type: CSEIndex; 

sonl *- Exp[sonl. typeANY I CheckExprLoop => RESUME [FALSE]]; 
IF ~OperandLhs[sonl] THEN ErrorDef s . errortree[nonAddressable, sonl]; 
type <- MakePointerType[RType[] , NormalType[target]] ; 
IF (attrl <r LongPath[sonl]) 

THEN type ^ MakeLongType[type. target]; 
RPop[]; RPush[type, FALSE]; RETURN 
END; 

DescOp: PUBLIC PROCEDURE [node: Treelndex. target: CSEIndex] =« 
BEGIN 
SELECT (tb+node) .name FROM 

base => Base[node, target]; 

length => Length[node] ; 

arraydesc => Desc[node, target]; 

ENDCASE «> ERROR; 
RETURN 
END; 

StripRelative: PROCEDURE [rType: CSEIndex] RETURNS [type: CSEIndex, bType: SEIndex] 
BEGIN 
WITH (seb+rType) SELECT FROM 

relative => BEGIN type ^ UnderType[offsetType]; bType *- baseType END; 

ENDCASE »> BEGIN type ♦- rType; bType ♦- SENull END; 
RETURN 
END; 

MakeRelativeType: PROCEDURE [type: CSEIndex. bType: SEIndex, hint: CSEIndex] 
RETURNS [CSEIndex] » 
BEGIN 

rType. tType: CSEIndex; 
WITH (seb+hint) SELECT FROM 
relative »> 

IF offsetType =* type AND UnderType[baseType] » UnderType[bType] 
THEN RETURN [hint]; 
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ENDCASE; 
tType ^ IF TypeForm[bType] « long OR TypeForfn[type] ■ long 

THEN MakeLongType[NormalType[type], type] 

ELSE type; 
rType <- makenonctxse[SIZE[relative constructor SymDef s .SERecord]]; 
(seb+rType) . typeinfo ^ relative[ 

baseType: bType, 

offsetType: type, 

resultType: tType]; 
(seb+rType) .marks ♦- (seb+rType) .mark4 <- TRUE; 
RETURN [rType] 
END; 

Base: PROCEDURE [node: Treelndex, target: CSEIndex] ■ 
BEGIN OPEN (tb+node); 
type, aType, nType, subTarget: CSEIndex; 
bType: SEIndex; 
long: BOOLEAN; 
IF 1 istlength[sonl] ■ 1 
THEN 
BEGIN 

sonl ^ Exp[sonl, typeANY]; 

[aType, bType] *- StripRelative[CanonicalType[RType[]]] ; 
RPop[]; 

nType ^ NormalType[aType]; [subTarget, ] ♦- StripRelative[target] ; 
WITH (seb+nType) SELECT FROM 
array => 

BEGIN name ^ addr; 
IF '-OperandLhs[sonl] 

THEN ErrorDefs.errortree[nonAddressable. sonl]; 
long *■ LongPath[sonl]; 
END; 
arraydesc => 
BEGIN 

long ♦- (seb+aType) . typetag » long; 
nType ♦- UnderType[describedType]; 
END; 
ENDCASE «> 

IF nType # typeANY THEN ErrorDef s.errortree[typeClash , sonl]; 
END 
ELSE 
BEGIN 

CheckLength[sonl, 1]; sonl ♦- updatel ist[sonl , VoidExp]; 
long <- FALSE; 
END; 
type <- MakePointerType[nType, NormalType[subTarget]]; 
IF (attrl *- long) THEN type ♦- MakeLongType[type, subTarget]; 
IF bType # SENull THEN type ♦- MakeRel ativeType[type, bType, target]; 
RPush[type, FALSE]; RETURN 
END; 

Length: PROCEDURE [node: Treelndex] « 
BEGIN OPEN (tb+node); 
type: CSEIndex; 
const: BOOLEAN; 
IF 1 istlength[sonl] » 1 
THEN 
BEGIN 

sonl <- Exp[sonl, typeANY]; 
type ^ RType[]; RPop[]; 
type ♦- IF (seb+type) .marks 

THEN Normal Type[StripRel at ive[CanonicalType[ type]]. type] 
ELSE typeANY; 
WITH (seb+type) SELECT FROM 
array => const *- TRUE; 
arraydesc »> const *- FALSE; 
ENDCASE «> 

BEGIN const ^ TRUE; 

IF type ^ typeANY THEN ErrorDef s .errortree[typeClash, sonl]; 
END; 
END 
ELSE 

BEGIN const <- TRUE; 

CheckLength[sonl, 1]; sonl ♦- updatel ist[sonl , VoidExp]; 

END; 
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RPush[dataPtr.typeINTEGER, const]; RETURN 
END; 

Desc: PROCEDURE [node: Treelndex. target: CSEIndex] ■ 
BEGIN OPEN (tb+node); 
type, subType: CSEIndex; 
aType, bType, cType: SEIndex; 
fixed, long: BOOLEAN; 
subNode: Treelndex; 

subTarget: CSEIndex » StripRelative[target] . type; 
nTarget: CSEIndex » NormalType[subTarget]; 
aType ^ bType <- SENull ; 
SELECT listlength[sonl] FROM 
1 »> 
BEGIN 
sonl ^ Exp[sonl, typeANY 

I CheckExprLoop «> RESUME [FALSE]]; 
IF ~OperandLhs[sonl] THEN ErrorDef s . errortree[nonAddressable, sonl]; 
long *r LongPath[sonl]; 

subType <- Canonica1Type[RType[]]; RPop[]; 
IF (seb+subType) . typetag « array 

THEN BEGIN aType <- OperandType[sonl] ; fixed ♦- TRUE END 
ELSE 

BEGIN fixed *- FALSE; 

IF subType # typeANY THEN ErrorDef s . errortree[typeClash, sonl]; 
END; 
mlpush[sonl]; 
pushtree[addr, 1]; 

setinfo[MakePointerType[subType, typeANY]]; setattr[l, long]; 
ni1push[IdentityMap[sonl]]; 

pushtree[1ength, 1]; setinfo[dataPtr. typelNTEGER] ; 
m1push[empty]; 
sonl <- makelist[3]; 
END; 
3 «> 

BEGIN subNode ^ GetNode[sonl]; 

(tb+subNode) .sonl «- Exp[(tb+subNode) .sonl , typeANY]; 
[subType, bType] <- StripRe1ative[CanonicalType[RType[]]]; 
RPop[]; 

SELECT (seb+Norma1Type[subType]) .typetag FROM 
basic, pointer => NULL; 

ENDCASE => ErrorDefs.errortree[typeC1ash, (tb+subNode) . sonl] ; 
long <r (seb+subType) . typetag « long; 

(tb+subNode) .son2 <- Rhs[(tb+subNode) .son2, dataPtr. typelNTEGER] ; 
RPop[]; 

IF (fixed ♦- (tb+subNode) .son3 ^ empty) 
THEN 
BEGIN 

(tb+subNode) .son3 ♦- TypeExp[(tb+subNode) .son3]; 
cType *- TypeForTree[(tb+subNode) .son3]; 
END; 
END; 
ENDCASE; 
IF aType = SENull 
THEN 
BEGIN 

WITH (seb+nTarget) SELECT FROM 
arraydesc => 

BEGIN subType ^ UnderType[describedType]; 
WITH t: (seb+subType) SELECT FROM 
array => 
IF -fixed 
OR TypePackDefs .EquivalentTypes[ 

[own , UnderType[t . component type]] , 
[own, UnderType[cType]]] 
THEN BEGIN aType <- describedType; GO TO old END; 
ENDCASE; 
END; 
ENDCASE; 
GO TO new; 
EXITS 

old "> NULL; 
new «> 
BEGIN 

subType ♦- makenonctxse[SIZE[array constructor SymDef s.SERecord]]; 
(seb+subType) . typeinfo ♦- array[ 
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packed: FALSE. 
lengthUsed: FALSE, 
comparable: FALSE, 
indextype: dataPtr . idCARDINAL, 

componenttype: IF fixed THEN cType ELSE typeANY]; 
(seb+subType) .marks ♦- (seb+subType) .mark4 <- TRUE; 
aType ^ subType; 
END; 
END; 
-- make type description 
BEGIN 

WITH t: (seb+nTarget) SELECT FROM 
arraydesc ■> 

IF TypePackDef s.EquivalentTypes[ 

[own, UnderType[t.describedType]]. 
[own, UnderType[aType]]] 
THEN GO TO old; 
ENDCASE -> 

IF -fixed AND target - typeANY 

THEN ErrorDef s .errortree[noTarget, [subtree[node]]] ; 
GO TO new; 
EXITS 

old »> type <- nTarget; 
new «> 
BEGIN 

type <- makenonctxse[SIZE[arraydesc constructor SymDef s .SERecord]]; 
(seb+type) . typeinfo *- arraydesc[describedType: aType]; 
(seb+type) .marks ♦- (seb+type) .mark4 ♦- TRUE; 
END; 
END; 
IF (attrl ♦- long) THEN type ♦- MakeLongType[type, subTarget]; 
IF bType # SENull THEN type ♦- MakeRel ativeType[type, bType, target]; 
RPush[type, FALSE]; RETURN 
END; 

END. 



